home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / arc_lbr / lzhuftp5.arc / LZH.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-01  |  13.8 KB  |  556 lines
  1. { LZHUF.C English version 1.0
  2.   Based on Japanese version 29-NOV-1988
  3.   LZSS coded by Haruhiko OKUMURA
  4.   Adaptive Huffman Coding coded by Haruyasu YOSHIZAKI
  5.   Edited and translated to English by Kenji RIKITAKE
  6.   Converted to Turbo Pascal 5.0
  7.     by Peter Sawatzki with assistance of Wayne Sullivan
  8. }
  9. {$i-,r-,v-,s-}
  10. Unit LZH;
  11. Interface
  12. type
  13.   bufar = array[0..0] of byte; {will be overindexed}
  14. var
  15.   WriteFromBuffer,
  16.   ReadToBuffer: procedure;
  17.   inbuf,outbuf: ^bufar;
  18.   inptr,inend,outptr,outend: word;
  19.  
  20.   procedure Encode (bytes: LongInt);
  21.   procedure Decode;
  22.  
  23. Implementation
  24. Const
  25. {-LZSS Parameters}
  26.   N         = 4096; {Size of string buffer}
  27.   F         = 60;   {60 Size of look-ahead buffer}
  28.   THRESHOLD = 2;
  29.   NODENIL   = N;    {End of tree's node}
  30.  
  31. {-Huffman coding parameters}
  32.   N_CHAR    = 256-THRESHOLD+F;
  33.                             {character code (= 0..N_CHAR-1)}
  34.   T         = N_CHAR*2 -1;  {Size of table}
  35.   R         = T-1;          {root position}
  36.   MAX_FREQ  = $8000; {update when cumulative frequency reaches to this value}
  37.  
  38. {-Tables for encoding/decoding upper 6 bits of sliding dictionary pointer}
  39. {-encoder table}
  40. p_len: array[0..63] of byte =
  41.        ($03,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,$06,$06,$06,$06,
  42.         $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
  43.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  44.         $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
  45.  
  46. p_code: array[0..63] of byte =
  47.        ($00,$20,$30,$40,$50,$58,$60,$68,$70,$78,$80,$88,$90,$94,$98,$9C,
  48.         $A0,$A4,$A8,$AC,$B0,$B4,$B8,$BC,$C0,$C2,$C4,$C6,$C8,$CA,$CC,$CE,
  49.         $D0,$D2,$D4,$D6,$D8,$DA,$DC,$DE,$E0,$E2,$E4,$E6,$E8,$EA,$EC,$EE,
  50.         $F0,$F1,$F2,$F3,$F4,$F5,$F6,$F7,$F8,$F9,$FA,$FB,$FC,$FD,$FE,$FF);
  51.  
  52. {-decoder table}
  53. d_code: array[0..255] of byte =
  54.        ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  55.         $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
  56.         $01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,$01,
  57.         $02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,$02,
  58.         $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  59.         $04,$04,$04,$04,$04,$04,$04,$04,$05,$05,$05,$05,$05,$05,$05,$05,
  60.         $06,$06,$06,$06,$06,$06,$06,$06,$07,$07,$07,$07,$07,$07,$07,$07,
  61.         $08,$08,$08,$08,$08,$08,$08,$08,$09,$09,$09,$09,$09,$09,$09,$09,
  62.         $0A,$0A,$0A,$0A,$0A,$0A,$0A,$0A,$0B,$0B,$0B,$0B,$0B,$0B,$0B,$0B,
  63.         $0C,$0C,$0C,$0C,$0D,$0D,$0D,$0D,$0E,$0E,$0E,$0E,$0F,$0F,$0F,$0F,
  64.         $10,$10,$10,$10,$11,$11,$11,$11,$12,$12,$12,$12,$13,$13,$13,$13,
  65.         $14,$14,$14,$14,$15,$15,$15,$15,$16,$16,$16,$16,$17,$17,$17,$17,
  66.         $18,$18,$19,$19,$1A,$1A,$1B,$1B,$1C,$1C,$1D,$1D,$1E,$1E,$1F,$1F,
  67.         $20,$20,$21,$21,$22,$22,$23,$23,$24,$24,$25,$25,$26,$26,$27,$27,
  68.         $28,$28,$29,$29,$2A,$2A,$2B,$2B,$2C,$2C,$2D,$2D,$2E,$2E,$2F,$2F,
  69.         $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F);
  70.  
  71. d_len: array[0..255] of byte =
  72.        ($03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  73.         $03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,$03,
  74.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  75.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  76.         $04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,$04,
  77.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  78.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  79.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  80.         $05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,$05,
  81.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  82.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  83.         $06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,$06,
  84.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  85.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  86.         $07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,
  87.         $08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08,$08);
  88.  
  89.   getbuf: word = 0;
  90.   getlen: byte = 0;
  91.   putbuf: word = 0;
  92.   putlen: word = 0;
  93.  
  94.   textsize: LongInt = 0;
  95.   codesize: LongInt = 0;
  96.   printcount: LongInt = 0;
  97.  
  98. var
  99.   text_buf: array[0..N + F - 2] of byte;
  100.   match_position, match_length: word;
  101.   lson,dad: array[0..N] of word;
  102.   rson:     array[0..N + 256] of word;
  103.  
  104.   freq: array[0..T] of word; {cumulative freq table}
  105.  
  106. {-pointing parent nodes. area [T..(T + N_CHAR - 1)] are pointers for leaves}
  107.   prnt: array [0..T+N_CHAR-1] of word;
  108.  
  109. {-pointing children nodes (son[], son[] + 1)}
  110.   son: array[0..T-1] of word;
  111.  
  112.   function getc: byte;
  113.   begin
  114.     getc:= inbuf^[inptr];
  115.     Inc(inptr);
  116.     if inptr=inend then ReadToBuffer
  117.   end;
  118.  
  119.   procedure putc (c: byte);
  120.   begin
  121.     outbuf^[outptr]:= c;
  122.     Inc(outptr);
  123.     if outptr=outend then
  124.       WriteFromBuffer
  125.   end;
  126.  
  127. procedure InitTree;
  128. {-Initializing tree}
  129. var
  130.   i: word;
  131. begin
  132.   for i:= N+1 to N+256 do rson[i] := NODENIL; {root}
  133.   for i:= 0 to N-1 do     dad[i]  := NODENIL; {node}
  134. end;
  135.  
  136. procedure InsertNode (r: word);
  137. {-Inserting node to the tree}
  138. Label
  139.   Done;
  140. var
  141.   i,p: word;
  142.   geq: boolean;
  143.   c: word;
  144. begin
  145.   geq:= true;
  146.   p:= N+1+text_buf[r];
  147.   rson[r]:= NODENIL;
  148.   lson[r]:= NODENIL;
  149.   match_length := 0;
  150.   while TRUE do begin
  151.     if geq then
  152.       if rson[p]=NODENIL then begin
  153.         rson[p]:= r;
  154.         dad[r] := p;
  155.         exit
  156.       end else
  157.         p:= rson[p]
  158.     else
  159.       if lson[p]=NODENIL then begin
  160.         lson[p]:= r;
  161.         dad[r] := p;
  162.         exit
  163.       end else
  164.         p:= lson[p];
  165.     i:= 1;
  166.     while (i<F) AND (text_buf[r+i]=text_buf[p+i]) do Inc(i);
  167.     geq:= (text_buf[r+i]>=text_buf[p+i]) or (i=F);
  168.  
  169.     if i>THRESHOLD then begin
  170.       if i>match_length then begin
  171.         match_position := (r-p) AND (N-1) -1;
  172.         match_length:= i;
  173.         if match_length>=F then goto done;
  174.       end;
  175.       if i=match_length then begin
  176.         c:= (r-p) AND (N-1) -1;
  177.         if c<match_position then match_position:= c
  178.       end
  179.     end
  180.   end;
  181.   Done:
  182.   dad[r]:= dad[p];
  183.   lson[r]:= lson[p];
  184.   rson[r]:= rson[p];
  185.   dad[lson[p]]:= r;
  186.   dad[rson[p]]:= r;
  187.   if rson[dad[p]]=p then
  188.     rson[dad[p]]:= r
  189.   else
  190.     lson[dad[p]]:= r;
  191.   dad[p]:= NODENIL; {remove p}
  192. end;
  193.  
  194. procedure DeleteNode (p: word);
  195. {-Delete node from the tree}
  196. var
  197.   q: word;
  198. begin
  199.   if dad[p] =NODENIL then exit; {unregistered}
  200.   if rson[p]=NODENIL then q:= lson[p] else
  201.   if lson[p]=NODENIL then q:= rson[p] else begin
  202.     q:= lson[p];
  203.     if rson[q]<>NODENIL then begin
  204.       repeat
  205.         q:= rson[q];
  206.       until rson[q]=NODENIL;
  207.       rson[dad[q]]:= lson[q];
  208.       dad[lson[q]]:= dad[q];
  209.       lson[q]:= lson[p];
  210.       dad[lson[p]]:= q;
  211.     end;
  212.     rson[q]:= rson[p];
  213.     dad[rson[p]]:= q;
  214.   end;
  215.   dad[q]:= dad[p];
  216.   if rson[dad[p]]=p then
  217.     rson[dad[p]]:= q
  218.   else
  219.     lson[dad[p]]:= q;
  220.   dad[p]:= NODENIL;
  221. end;
  222.  
  223. function GetBit: byte;
  224. {-get one bit}
  225. begin
  226.   while getlen<=8 do begin
  227.     getbuf:= getbuf OR (WORD(getc) SHL (8-getlen));
  228.     Inc(getlen,8);
  229.   end;
  230.   GetBit:= getbuf SHR 15;
  231.   {if (getbuf AND $8000)>0 then GetBit:= 1 else GetBit:= 0;}
  232.   getbuf:= getbuf SHL 1;
  233.   Dec(getlen);
  234. end;
  235.  
  236. function GetByte: Byte;
  237. {-get a byte}
  238. begin
  239.   while getlen<=8 do begin
  240.     getbuf:= getbuf OR (WORD(getc) SHL (8 - getlen));
  241.     Inc(getlen,8);
  242.   end;
  243.   GetByte:= Hi(getbuf);
  244.   getbuf:= getbuf SHL 8;
  245.   Dec(getlen,8);
  246. end;
  247.  
  248. procedure Putcode (l: byte; c: word);
  249. {-output l bits}
  250. begin
  251.   putbuf:= putbuf OR (c SHR putlen);
  252.   Inc(putlen,l);
  253.   if putlen>=8 then begin
  254.     putc(Hi(putbuf));
  255.     Dec(putlen,8);
  256.     if putlen>=8 then begin
  257.       putc(Lo(putbuf));
  258.       Inc(codesize,2);
  259.       Dec(putlen,8);
  260.       putbuf:= c SHL (l-putlen);
  261.     end else begin
  262.       putbuf:= Swap(putbuf AND $FF); {SHL 8;}
  263.       Inc(codesize);
  264.     end
  265.   end
  266. end;
  267.  
  268. procedure StartHuff;
  269. {-initialize freq tree}
  270. var
  271.   i,j: word;
  272. begin
  273.   for i:= 0 to N_CHAR-1 do begin
  274.     freq[i]:= 1;
  275.     son[i] := i+T;
  276.     prnt[i+T]:= i
  277.   end;
  278.   i:= 0; j:= N_CHAR;
  279.   while j<=R do begin
  280.     freq[j]:= freq[i]+freq[i+1];
  281.     son[j] := i;
  282.     prnt[i]:= j;
  283.     prnt[i+1]:= j;
  284.     Inc(i,2); Inc(j)
  285.   end;
  286.   freq[T]:= $FFFF;
  287.   prnt[R]:= 0;
  288. end;
  289.  
  290. procedure reconst;
  291. {-reconstruct freq tree }
  292. var
  293.   i,j,k,f,l: word;
  294. begin
  295.   {-halven cumulative freq for leaf nodes}
  296.   j:= 0;
  297.   for i:= 0 to T-1 do
  298.     if son[i]>=T then begin
  299.       freq[j]:= (freq[i]+1) SHR 1;
  300.       son[j] := son[i];
  301.       Inc(j)
  302.     end;
  303.   {-make a tree : first, connect children nodes}
  304.   i:= 0; j:= N_CHAR;
  305.   while j<T do begin
  306.     k:= i+1;
  307.     f:= freq[i]+freq[k];
  308.     freq[j]:= f;
  309.     k:= j-1;
  310.     while f<freq[k] do Dec(k);
  311.     Inc(k);
  312.     l:= (j-k)*2;
  313.  
  314.     move(freq[k],freq[k+1],l);
  315.     freq[k]:= f;
  316.     move(son[k],son[k+1],l);
  317.     son[k]:= i;
  318.     Inc(i,2);
  319.     Inc(j)
  320.   end;
  321.   {-connect parent nodes}
  322.   for i:= 0 to T-1 do begin
  323.     k:= son[i];
  324.     prnt[k]:= i;
  325.     if k<T then
  326.       prnt[k+1]:= i
  327.   end
  328. end;
  329.  
  330. procedure update(c: word);
  331. {-update freq tree}
  332. var
  333.   i,j,k,l: word;
  334. begin
  335.   if freq[R]=MAX_FREQ then reconst;
  336.   c:= prnt[c+T];
  337.   repeat
  338.     Inc(freq[c]);
  339.     k:= freq[c];
  340.     {-swap nodes to keep the tree freq-ordered}
  341.     l:= c+1;
  342.     if k>freq[l] then begin
  343.       while k>freq[l+1] do Inc(l);
  344.       freq[c]:= freq[l];
  345.       freq[l]:= k;
  346.  
  347.       i:= son[c];
  348.       prnt[i]:= l;
  349.       if i<T then prnt[i+1]:= l;
  350.  
  351.       j:= son[l];
  352.       son[l]:= i;
  353.  
  354.       prnt[j]:= c;
  355.       if j<T  then prnt[j+1]:= c;
  356.       son[c]:= j;
  357.  
  358.       c := l;
  359.     end;
  360.     c:= prnt[c]
  361.   until c=0; {do it until reaching the root}
  362. end;
  363.  
  364. procedure EncodeChar (c: word);
  365. var
  366.   code,len,k: word;
  367. begin
  368.   code:= 0;
  369.   len:= 0;
  370.   k:= prnt[c+T];
  371.  
  372.   {-search connections from leaf node to the root}
  373.   repeat
  374.     code:= code SHR 1;
  375.     {-if node's address is odd, output 1 else output 0}
  376.     if (k AND 1)>0 then Inc(code,$8000);
  377.     Inc(len);
  378.     k:= prnt[k];
  379.   until k=R;
  380.   Putcode(len,code);
  381.   update(c)
  382. end;
  383.  
  384. procedure EncodePosition(c: word);
  385. var
  386.   i: word;
  387. begin
  388.   {-output upper 6 bits with encoding}
  389.   i:= c SHR 6;
  390.   Putcode(p_len[i], WORD(p_code[i]) SHL 8);
  391.   {-output lower 6 bits directly}
  392.   Putcode(6, (c AND $3F) SHL 10);
  393. end;
  394.  
  395. procedure EncodeEnd;
  396. begin
  397.   if putlen>0 then begin
  398.     putc(Hi(putbuf));
  399.     Inc(codesize)
  400.   end
  401. end;
  402.  
  403. function DecodeChar: word;
  404. var
  405.   c: word;
  406. begin
  407.   c:= son[R];
  408.   {-start searching tree from the root to leaves.
  409.     choose node #(son[]) if input bit = 0
  410.     else choose #(son[]+1) (input bit = 1)}
  411.   while c<T do c:= son[c+GetBit];
  412.   Dec(c,T);
  413.   update(c);
  414.   DecodeChar:= c
  415. end;
  416.  
  417. function DecodePosition: word;
  418. var
  419.   i,j,c: word;
  420. begin
  421.   {-decode upper 6 bits from given table}
  422.   i:= GetByte;
  423.   c:= WORD(d_code[i]) SHL 6;
  424.   j:= d_len[i];
  425.   {-input lower 6 bits directly}
  426.   Dec(j,2);
  427.   while j>0 do begin
  428.     Dec(j);
  429.     i:= (i SHL 1) OR GetBit;
  430.   end;
  431.   DecodePosition:= c OR (i AND $3F);
  432. end;
  433.  
  434. {-Compression }
  435. procedure Encode (bytes: LongInt);
  436. {-Encoding/Compressing}
  437. type
  438.   ByteRec = record
  439.               b0,b1,b2,b3: byte
  440.             end;
  441. var
  442.   i,c,len,r,s,last_match_length: word;
  443. begin
  444.   {-write size of original text}
  445.   with ByteRec(Bytes) do begin
  446.     putc(b0);
  447.     putc(b1);
  448.     putc(b2);
  449.     putc(b3)
  450.   end;
  451.   if bytes=0 then exit;
  452.   textsize:= 0;
  453.   StartHuff;
  454.   InitTree;
  455.   s:= 0;
  456.   r:= N-F;
  457.   fillchar(text_buf[0],r,' ');
  458.   len:= 0;
  459.   while (len<F) AND (inptr OR inend>0) do begin
  460.     text_buf[r+len]:= getc;
  461.     Inc(len)
  462.   end;
  463.   textsize := len;
  464.   for i:= 1 to F do InsertNode(r - i);
  465.   InsertNode(r);
  466.   repeat
  467.     if match_length>len then match_length:= len;
  468.     if match_length<=THRESHOLD then begin
  469.       match_length := 1;
  470.       EncodeChar(text_buf[r])
  471.     end else begin
  472.       EncodeChar(255 - THRESHOLD + match_length);
  473.       EncodePosition(match_position)
  474.     end;
  475.     last_match_length := match_length;
  476.     i:= 0;
  477.     while (i<last_match_length) AND (inptr OR inend>0) do begin
  478.       Inc(i);
  479.       DeleteNode(s);
  480.       c:= getc;
  481.       text_buf[s]:= c;
  482.       if s<F-1 then text_buf[s+N]:= c;
  483.       s:= (s+1) AND (N-1);
  484.       r:= (r+1) AND (N-1);
  485.       InsertNode(r);
  486.     end;
  487.     Inc(textsize,i);
  488.     if textsize>printcount then begin
  489.       write(textsize,#13);
  490.       Inc(printcount,1024)
  491.     end;
  492.     while i<last_match_length do begin
  493.       Inc(i);
  494.       DeleteNode(s);
  495.       s := (s+1) AND (N-1);
  496.       r := (r+1) AND (N-1);
  497.       Dec(len);
  498.       if len>0 then InsertNode(r)
  499.     end;
  500.   until len=0;
  501.   EncodeEnd;
  502.   writeln('input:  ',textsize,' bytes');
  503.   writeln('output: ',codesize,' bytes');
  504.   writeln('compression: ',textsize*100 DIV codesize,'%');
  505. end;
  506.  
  507. procedure Decode;
  508. {-Decoding/Uncompressing}
  509. type
  510.   ByteRec = Record
  511.               b0,b1,b2,b3: byte
  512.             end;
  513. var
  514.   i,j,k,r,c: word;
  515.   count: LongInt;
  516. begin
  517.   {-read size of original text}
  518.   with ByteRec(textsize) do begin
  519.     b0:= getc;
  520.     b1:= getc;
  521.     b2:= getc;
  522.     b3:= getc
  523.   end;
  524.   if textsize=0 then exit;
  525.   StartHuff;
  526.   fillchar(text_buf[0],N-F,' ');
  527.   r:= N-F;
  528.   count:= 0;
  529.   while count<textsize do begin
  530.     c:= DecodeChar;
  531.     if c<256 then begin
  532.       putc(c);
  533.       text_buf[r]:= c;
  534.       r:= (r+1) AND (N-1);
  535.       Inc(count)
  536.     end else begin
  537.       i:= (r-DecodePosition-1) AND (N-1);
  538.       j:= c-255+THRESHOLD;
  539.       for k:= 0 to j-1 do begin
  540.         c:= text_buf[(i+k) AND (N-1)];
  541.         putc(c);
  542.         text_buf[r]:= c;
  543.         r:= (r+1) AND (N-1);
  544.         Inc(count)
  545.       end;
  546.     end;
  547.     if count>printcount then begin
  548.       write(count,#13);
  549.       Inc(printcount,1024)
  550.     end
  551.   end;
  552.   writeln(count);
  553. end;
  554.  
  555. end.
  556.